Cream of the Crop 1/Cream of the Crop 1.iso/PROGRAM/STREAM13.ARJ/STREAMS.PAS

Pascal/Delphi Source File | 1992-05-18 | 68KB | 2,363 lines

{$B-}   { Use fast boolean evaluation. }

unit Streams;

{ Unit to provide enhancements to TV Objects unit streams in the form
  of several filters, i.e. stream clients, and other streams. }

{ Version 1.2 - Adds TNulStream and TXMSStream, from suggestion and
                code by Stefan Boether; TBitFilter, from suggestion
                by Rene Seguin; added call to Flush to TFilter.Done;
                UseBuf and OwnMem to TRAMStream.
                TTextFilter fixed so that mixed access methods work.
          1.3 - Added TDupFilter, TSequential, CRCs and Checksums }

{$ifndef windows}
  {$O-}
  { Don't overlay this unit; it contains code that needs to participate
         in overlay management. }
{$endif

{  Hierarchy:

   TStream                  (from Objects)
     TFilter                Base type for filters
       TEncryptFilter       Encrypts as it writes; decrypts as it reads
       TLZWFilter           Compresses as it writes; expands as it reads
       TTextFilter          Provides text file interface to stream
       TLogFilter           Provides logging of text file activity
       TBitFilter           Allows reads & writes by the bit
       TDupFilter           Duplicates output, checks for matching input
       TSequential          Filter that doesn't allow Seek
         TChksumFilter      Calculates 16 bit checksum for reads and writes
         TCRC16Filter       Calculates XMODEM-style 16 bit CRC
         TCRCARCFilter      Calculates ARC-style 16 bit CRC
         TCRC32Filter       Calculates ZIP/ZModem-style 32 bit CRC
     TNulStream             Eats writes, returns constant on reads
     TRAMStream             Stream in memory
     TXMSStream             Stream in XMS
     TDOSStream             (from Objects)
       TBufStream           (from Objects)
         TNamedBufStream    Buffered file stream that knows its name
           TTempBufStream   Buffered file stream that erases itself when done

   Procedures & functions:

   TempStream      allocates a temporary stream
   OvrInitStream   like OvrInitEMS, but buffers overlays on a stream
                   May be called several times to buffer different
                   segments on different streams.
   OvrDetachStream detaches stream from overlay system
   OvrDisposeStreams detaches all streams from overlay system and disposes of
                   them
   OvrSizeNeeded   Calculates the size needed to load the rest of the segments
                   to a stream
   OvrLoadAll      immediately copies as many overlay segments to the stream
                   as will fit
   UpdateChkSum    updates a 16 bit checksum value
   UpdateCRC16     updates a CRC16 value
   UpdateCRCARC    updates a CRCARC value
   UpdateCRC32     updates a CRC32 value

}

interface

{$ifdef windows}
uses strings,windos,winprocs,wobjects;
{$else}
uses DOS, Overlay, Objects;
{$endif}

const
  stBadMode = 1;                  { Bad mode for stream - operation not supported
                                    info = mode }
  stStreamFail = 2;               { Stream init failed }
  stBaseError = 3;                { Error in base stream
                                    info = base error value }
  stMemError = 4;                 { Not enough memory for operation }
  stSigError = 5;                 { Problem with LZ file signature }
  stUsedAll = 6;                  { Used limit of allocation }
  stUnsupported = 7;              { Operation unsupported in this stream }
  stBase2Error = 8;               { Error in second base
                                    info = base2 error value }
  stMisMatch = 9;                 { Two bases don't match
                                    info = mismatch position in current buffer }
  stIntegrity = 10;               { Stream has detected an integrity error
                                    in a self check.  Info depends on
                                    stream type. }
type
  TOpenMode = $3C00..$3DFF;       { Allowable DOS stream open modes }
  {$ifdef windows}
  FNameStr = PChar;            { To make streams take names as in the manual }
  {$endif}

  PFilter = ^TFilter;
  TFilter =
    object(TStream)
    { Generic object to filter another stream.  TFilter just passes everything
      through, and mirrors the status of the base stream }

      Base : PStream;
      { Pointer to the base stream. }

      Startofs : LongInt;
      { The offset of the start of the filter in the base stream. }

      constructor Init(ABase : PStream);
        { Initialize the filter with the given base. }

      destructor Done; virtual;
        { Flush filter, then dispose of base. }

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;
      procedure Flush; virtual;

      function CheckStatus : Boolean; virtual;
    { Return true if status is stOK.
      If status is stOK, but base is not, then reset the base.  This is a poor
      substitute for a virtual Reset method. }

      procedure CheckBase;
        { Check base stream for error, and copy status using own Error method. }
    end;

  PEncryptFilter = ^TEncryptFilter;
  TEncryptFilter =
    object(TFilter)
  { Filter which encrypts text going in or out; encrypting twice with the same
    key decrypts. Not very sophisticated encryption. }

      Key : LongInt;
      { Key is used as a Randseed replacement }

      constructor Init(Akey : LongInt; ABase : PStream);
        { Init with a given key }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

const
  MaxStack = 4096;                { must match lzwstream.asm declaration! }

type
  PLZWTables = ^TLZWTables;
  TLZWTables =
    record
      Collision : array[0..MaxStack-1] of Byte; { Hash table entries }
      PrefixTable : array[0..MaxStack-1] of Word; { Code for preceding stringf }
      SuffixTable : array[0..MaxStack-1] of Byte; { Code for current character }
      ChildTable : array[0..MaxStack-1] of Word; { Next duplicate in collision
                                                 list }
      CharStack : array[0..MaxStack-1] of Byte; { Decompression stack }
      StackPtr : Word;            { Decompression stack depth }
      Prefix : Word;              { Previous code string }
      TableUsed : Word;           { # string table entries used }
      InputPos : Word;            { Index in input buffer }
      OutputPos : Word;           { Index in output buffer }
      LastHit : Word;             { Last empty slot in collision
                                                 table }
      CodeBuf : Word;
      SaveIP : Word;
      SaveAX : Word;
      SaveCX : Word;
      SaveDX : Word;

      NotFound : Byte;            { Character combination found
                                                 flag }
    end;

  PLZWFilter = ^TLZWFilter;
  TLZWFilter =
    object(TFilter)
      Mode : Word;                { Either stOpenRead or stOpenWrite. }
      Size,                       { The size of the expanded stream. }
      Position : LongInt;         { The current position in the expanded stream }
      Tables : PLZWTables;        { Tables holding the compressor state. }

      constructor Init(ABase : PStream; AMode : TOpenMode);
    {  Create new compressor stream, to use ABase as the source/destination
       for data.  Mode must be stOpenRead or stOpenWrite. }

      destructor Done; virtual;
    {  Flushes all data to the stream, and writes the uncompressed
       filesize to the head of it before calling TFilter.done. }

      procedure Flush; virtual;
      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;

      procedure Seek(Pos : LongInt); virtual;
    {  Seek is not supported at all in Write mode.  In Read mode, it is
       slow for seeking forwards, and very slow for seeking backwards:
       it rewinds the file to the start and seeks forward from there. }

      procedure Truncate; virtual;
    {  Truncate is not supported in either mode, and always causes a
       call to Error. }

      procedure Write(var Buf; Count : Word); virtual;
    end;

type
  PTextFilter = ^TTextFilter;
  TTextFilter =
    object(TFilter)
  { A filter to provide ReadLn/WriteLn interface to a stream.  First
    open the stream and position it, then pass it to this filter;
    then Reset, Rewrite, or Append the Textfile variable, and do all
    reads and writes to it; they'll go to the stream through a TFDD. }

      Textfile : Text;
      { The fake text file to use with Read(ln)/Write(ln) }

      constructor Init(ABase : PStream; AName : String);
    { Initialize the interface to ABase; stores AName in the name field of
      Textfile. }

      destructor Done; virtual;
        { Flushes the Textfile, then closes and disposes of the base stream. }

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PLogFilter = ^TLogFilter;
  TLogFilter =
    object(TFilter)
      { A filter to log activity on a text file. }

      LogList : ^Text;            { A pointer to the first logged file }

      constructor init(ABase:PStream);
      { Initializes filter, but doesn't start logging anything }

      destructor Done; virtual;
      { Stops logging all files, and closes & disposes of the base stream }

      procedure Log(var F : Text);
    { Logs all input and output to F to the stream.  You must do the Assign to
      F first, and not do another Assign without closing F. }

      function Unlog(var F : Text) : Boolean;
    { Stops logging of F.  Called automatically if file is closed. Returns
      false and does nothing on error. }
    end;

  TBit = 0..1;                    { A single bit }

  PBitFilter = ^TBitFilter;
  TBitFilter =
    object(TFilter)
      BitPos : ShortInt;
      { Position of stream relative to base file.  Negative values signal
        that the buffer is unchanged from the file, positive values signal
        that the file needs to be updated.  Zero signals an empty buffer. }
      Mask : Byte;                { Mask to extract next bit from buffer }
      Buffer : Byte;              { Buffer of next 8 bits from stream }
      AtEnd : Boolean;            { Flag to signal that we're at the end
                                    of the base, and we shouldn't read
                                    it.  Bases that change in length should
                                    set this to false. }

      constructor Init(ABase : PStream);

      procedure Flush; virtual;   { Flush buffer to stream }
      procedure Seek(Pos : LongInt); virtual; { Seek to bit at start of
                                               pos byte }
      procedure Read(var Buf; Count : Word); virtual;
      procedure Write(var Buf; Count : Word); virtual;

      function GetBit : TBit;     { Get next bit from stream }
      function GetBits(Count : Byte) : LongInt; { Get up to 32 bits }
      procedure ReadBits(var Buf; Count : LongInt); { Read bits from stream }

      procedure PutBit(ABit : TBit); { Put one bit to stream }
      procedure PutBits(ABits : LongInt; Count : Byte); { Put up to 32 bits }
      procedure WriteBits(var Buf; Count : LongInt); { Write count bits to stream }

      procedure SeekBit(Pos : LongInt); { Seek to particular bit }
      function GetBitPos : LongInt;

      procedure CopyBits(var S : TBitFilter; Count : LongInt); { Copy bits from S }
      procedure ByteAlign;        { Seek forward to next byte boundary. }

      procedure PrepareBuffer(ForRead : Boolean);
        { Internal method to assure that buffer is valid }
    end;

  PDupFilter = ^TDupFilter;
  TDupFilter =
    object(TFilter)         { Duplicates output, confirms matching input }
      Base2 : PStream;
      { Pointer to the second base. }

      Startofs2 : LongInt;
      { The offset of the start of the filter in the second base. }

      constructor Init(ABase, ABase2 : PStream);
        { Initialize the filter with the given bases. }

      destructor Done; virtual;
        { Flush filter, then dispose of both bases. }

      function MisMatch(var buf1,buf2; count:word):word; virtual;
        { Checks for a mismatch between the two buffers.  Returns
          the byte number of the mismatch (1 based), or 0 if they
          test equal.  This default method checks for an exact match. }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;
      procedure Flush; virtual;

      function CheckStatus : Boolean; virtual;
    { Return true if status is stOK.
      If status is stOK, but base is not, then reset the base.  This is a poor
      substitute for a virtual Reset method. }

      procedure CheckBase2;
        { Check 2nd base stream for error, and copy status using own Error method. }
    end;

  PSequential = ^TSequential;
  TSequential =
    object(TFilter)                        { Filter for sequential access only }
      procedure Seek(pos:longint); virtual;{ Signals stUnsupported if a Seek is attempted }
    end;

  PChksumFilter = ^TChksumFilter;
  TChksumFilter =
    object(TSequential)                    { Calculates 16 bit checksum of
                                             bytes read/written. }
      Chksum : word;

      constructor Init(ABase : PStream;AChksum:word);
        { Initialize the filter with the given base and starting checksum. }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PCRC16Filter = ^TCRC16Filter;
  TCRC16Filter =
    object(TSequential)      { Calculates XMODEM style 16 bit CRC }
      CRC16 : word;

      constructor Init(ABase : PStream;ACRC16:word);
        { Initialize the filter with the given base and starting CRC. }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PCRCARCFilter = ^TCRCARCFilter;
  TCRCARCFilter =
    object(TSequential)      { Calculates ARC-style 16 bit CRC }
      CRCARC : word;

      constructor Init(ABase : PStream;ACRCARC:word);
        { Initialize the filter with the given base and starting CRC. }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PCRC32Filter = ^TCRC32Filter;
  TCRC32Filter =
    object(TSequential)      { Calculates PKZIP and ZModem style 32 bit CRC }
      CRC32 : longint;

      constructor Init(ABase : PStream;ACRC32:longint);
        { Initialize the filter with the given base and starting CRC. }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;


  PNulStream = ^TNulStream;
  TNulStream =
    object(TStream)
      Position : LongInt;         { The current position for the stream. }
      Value : Byte;               { The value returned on reads. }

      constructor Init(AValue : Byte);
      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  Pbyte_array = ^Tbyte_array;
  Tbyte_array = array[0..65520] of Byte; { Type used as a buffer. }

  PRAMStream = ^TRAMStream;
  TRAMStream =
    object(TStream)
      Position : Word;            { The current position for the stream. }

      Size : Word;                { The current size of the stream. }
      Alloc : Word;               { The size of the allocated block of memory. }

      Buffer : Pbyte_array;       { Points to the stream data. }
      OwnMem : Boolean;           { Whether Done should dispose of data.}

      constructor Init(Asize : Word);
    { Attempt to initialize the stream to a block size of Asize;
       initial stream size and position are 0. }
      constructor UseBuf(ABuffer : Pointer; Asize : Word);
     { Initialize the stream using the specified buffer.  OwnMem is set
       to false, so the buffer won't be disposed of. }

      destructor Done; virtual;
        { Dispose of the stream. }

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PXMSStream = ^TXMSStream;
  TXMSStream =
    object(TStream)
      Handle : Word;              { XMS handle }
      MaxBlocks : Word;           { Max 1K blocks to allocate }
      BlocksUsed : Word;          { Number of 1K blocks used. Always allocates
                                    at least one byte more than Size. }
      Size : LongInt;             { The current size of the stream }
      Position : LongInt;         { Current position }

      constructor Init(AMaxBlocks : Word);
      destructor Done; virtual;

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;

      procedure NewBlock;         { Internal method to allocate a block }
      procedure FreeBlock;        { Internal method to free one block }
    end;

function xms_MemAvail : Word;
  { Returns number of available XMS blocks. }
function xms_MaxAvail : Word;
  { Returns size of largest available XMS block. }

type
  PNamedBufStream = ^TNamedBufStream;
  TNamedBufStream =
    object(TBufStream)
      { A simple descendant of TBufStream which knows its own name. }

    {$ifdef windows}
    filename : PChar;
    {$else}
      Filename : PString;
    {$endif}
      { The name of the stream. }

      constructor Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
        { Open the file with the given name, and save the name. }

      destructor Done; virtual;
        { Close the file. }

    end;

  PTempBufStream = ^TTempBufStream;
  TTempBufStream =
    object(TNamedBufStream)
      { A temporary buffered file stream, which deletes itself when done.}

      constructor Init(ABufSize : Word);
  { Create a temporary file with a unique name, in the directory
    pointed to by the environment varable TEMP or in the current
    directory, and open it in read/write mode.   }

      destructor Done; virtual;
        { Close and delete the temporary file. }

    end;

type
  TStreamType = (NoStream, RAMStream, EMSStream, XMSStream, FileStream);
  { The type of stream that a tempstream might be. }

const
  NumTypes = Ord(FileStream);
  BufSize : Word = 2048;          { Buffer size if buffered stream is used. }

type
  TStreamRanking = array[1..NumTypes] of TStreamType;
  { A ranking of preference for a type of stream, from most to least preferred }

const ForSpeed : TStreamRanking = (RAMStream, EMSStream, XMSStream, FileStream);
  { Streams ordered for speed }

const ForSize : TStreamRanking = (FileStream, EMSStream, XMSStream, RAMStream);
  { Streams ordered for low impact on the heap }

const ForSizeInMem : TStreamRanking = (EMSStream, XMSStream, RAMStream, NoStream);
  { Streams in memory only, ordered as #ForSize#. }

const ForOverlays : TStreamRanking = (EMSStream, XMSStream, FileStream, NoStream);
  { Streams ordered for speed, but never in RAM. }

function TempStream(InitSize, MaxSize : LongInt;
                    Preference : TStreamRanking) : PStream;

{      This procedure returns a pointer to a temporary stream from a
       choice of 3, specified in the Preference array.  The first stream
       type listed in the Preference array which can be successfully
       created with the given sizes will be returned, or Nil if none can
       be made. }

{$ifndef windows}
procedure OvrInitStream(S : PStream);
{ Copies overlay segment code to S as new segments are loaded,
  and does reloads from there.  Allows multiple calls, to buffer
  different segments on different streams. }

procedure OvrDetachStream(BadS : PStream);
  { Makes sure that the overlay system makes no references to BadS. }

procedure OvrDisposeStreams;
  { Detaches and disposes of all streams being used by the overlay system }

function OvrSizeNeeded : LongInt;
{ Returns the size required to load any segments which still haven't
  been loaded to a stream. }

function OvrLoadAll : Boolean;
{ Forces all overlay segments to be copied into the stream; if successful
  (true) then no more references to the overlay file will be made. }
{$endif windows}

Function UpdateChksum(Initsum: Word; Var InBuf; InLen : Word) : Word;
{ Updates the checksum Initsum by adding InLen bytes from InBuf }

Function UpdateCRC16(InitCRC : Word; Var InBuf; InLen : Word) : Word;
{ I believe this is the CRC used by the XModem protocol.  The transmitting
  end should initialize with zero, UpdateCRC16 for the block, Continue the
  UpdateCRC16 for two nulls, and append the result (hi order byte first) to
  the transmitted block.  The receiver should initialize with zero and
  UpdateCRC16 for the received block including the two byte CRC.  The
  result will be zero (why?) if there were no transmission errors.  (I have
  not tested this function with an actual XModem implementation, though I
  did verify the behavior just described.  See TESTCRC.PAS.) }


Function UpdateCRCArc(InitCRC : Word; Var InBuf; InLen : Word) : Word;
{ This function computes the CRC used by SEA's ARC utility.  Initialize
  with zero. }

Function UpdateCRC32(InitCRC : LongInt; Var InBuf; InLen : Word) : LongInt;
{ This function computes the CRC used by PKZIP and Forsberg's ZModem.
  Initialize with high-values ($FFFFFFFF), and finish by inverting all bits
  (Not). }

implementation

  constructor TFilter.Init(ABase : PStream);
  begin
    TStream.Init;
    Base := ABase;
    CheckBase;
    if Status = stOK then
      Startofs := Base^.GetPos;
  end;

  destructor TFilter.Done;
  begin
    if Base <> nil then
    begin
      Flush;
      Dispose(Base, Done);
    end;
    TStream.Done;
  end;

  function TFilter.GetPos : LongInt;
  begin
    if CheckStatus then
    begin
      GetPos := Base^.GetPos-Startofs;
      CheckBase;
    end;
  end;

  function TFilter.GetSize : LongInt;
  begin
    if CheckStatus then
    begin
      GetSize := Base^.GetSize-Startofs;
      CheckBase;
    end;
  end;

  procedure TFilter.Read(var Buf; Count : Word);
  begin
    if CheckStatus then
    begin
      Base^.Read(Buf, Count);
      CheckBase;
    end;
  end;

  procedure TFilter.Seek(Pos : LongInt);
  begin
    if CheckStatus then
    begin
      Base^.Seek(Pos+Startofs);
      CheckBase;
    end;
  end;

  procedure TFilter.Truncate;
  begin
    if CheckStatus then
    begin
      Base^.Truncate;
      CheckBase;
    end;
  end;

  procedure TFilter.Write(var Buf; Count : Word);
  begin
    if CheckStatus then
    begin
      Base^.Write(Buf, Count);
      CheckBase;
    end;
  end;

  procedure TFilter.Flush;
  begin
    if CheckStatus then
    begin
      Base^.Flush;
      CheckBase;
    end;
  end;

  function TFilter.CheckStatus : Boolean;
  begin
    if (Status = stOK) and (Base^.Status <> stOK) then
      Base^.Reset;
    CheckStatus := Status = stOK;
  end;

  procedure TFilter.CheckBase;
  begin
    if Base^.Status <> stOK then
      Error(stBaseError, Base^.Status);
  end;

  constructor TEncryptFilter.Init(Akey : LongInt; ABase : PStream);
  begin
    TFilter.Init(ABase);
    Key := Akey;
  end;

  procedure TEncryptFilter.Read(var Buf; Count : Word);
  var
    i : Word;
    SaveSeed : LongInt;
    Bytes : Tbyte_array absolute Buf;
  begin
    SaveSeed := RandSeed;
    RandSeed := Key;
    TFilter.Read(Buf, Count);
    for i := 0 to Count-1 do
      Bytes[i] := Bytes[i] xor Random(256);
    Key := RandSeed;
    RandSeed := SaveSeed;
  end;

  procedure CycleKey(Key, Cycles : LongInt);
{ For cycles > 0, mimics cycles calls to the TP random number generator.
  For cycles < 0, backs it up the given number of calls. }
  var
    i : LongInt;
    Junk : Integer;
    SaveSeed : LongInt;
  begin
    if Cycles > 0 then
    begin
      SaveSeed := RandSeed;
      RandSeed := Key;
      for i := 1 to Cycles do
        Junk := Random(0);
      Key := RandSeed;
      RandSeed := Key;
    end
    else
      for i := -1 downto Cycles do
        Key := (Key-1)*(-649090867);
  end;

  procedure TEncryptFilter.Seek(Pos : LongInt);
  var
    OldPos : LongInt;
  begin
    OldPos := GetPos;
    TFilter.Seek(Pos);
    CycleKey(Key, Pos-OldPos);
  end;

  procedure TEncryptFilter.Write(var Buf; Count : Word);
  var
    i : Word;
    SaveSeed : LongInt;
    BufPtr : ^Byte;
    BufPtrOffset : Word absolute BufPtr;
    Buffer : array[0..255] of Byte;
  begin
    SaveSeed := RandSeed;
    RandSeed := Key;
    BufPtr := @Buf;
    while Count > 256 do
    begin
      Move(BufPtr^, Buffer, 256);
      for i := 0 to 255 do
        Buffer[i] := Buffer[i] xor Random(256);
      TFilter.Write(Buffer, 256);
      Dec(Count, 256);
      Inc(BufPtrOffset, 256);
    end;
    Move(BufPtr^, Buffer, Count);
    for i := 0 to Count-1 do
      Buffer[i] := Buffer[i] xor Random(256);
    TFilter.Write(Buffer, Count);
    Key := RandSeed;
    RandSeed := SaveSeed;
  end;


  { ******* LZW code ******* }

{$L LZWSTREAM.OBJ}

  procedure Initialise(Tables : PLZWTables); External;

  function PutSignature(Tables : PLZWTables) : Boolean; External;

  function Crunch(InBufSize, OutBufSize : Word;
                  var InBuffer, OutBuffer;
  Tables : PLZWTables) : Pointer; External;

{  Crunch some more text.  Stops when Inbufsize bytes are used up, or
   output buffer is full.   Returns bytes used in segment, bytes written
   in offset of result }

  function FlushLZW(var OutBuffer;
  Tables : PLZWTables) : Word; External;
{  Flush the remaining characters to signal EOF.  Needs space for up to
   3 characters. }

  function GetSignature(var InBuffer, Dummy;
  Tables : PLZWTables) : Boolean; External;
{ Initializes for reading, and checks for 'LZ' signature in start of compressed
  code.  Inbuffer must contain at least 3 bytes.  Dummy is just there to put the
  Inbuffer in the right spot }

  function Uncrunch(InBufSize, OutBufSize : Word;
                    var InBuffer, OutBuffer;
  Tables : PLZWTables) : Pointer; External;
{  Uncrunch some text.  Will stop when it has done Outbufsize worth or has
   exhausted Inbufsize worth.  Returns bytes used in segment, bytes written
   in offset of result }

  constructor TLZWFilter.Init(ABase : PStream; AMode : TOpenMode);
    {  Create new compressor stream, to use ABase as the source/destination
       for data.  Mode must be stOpenRead or stOpenWrite. }
  var
    Buffer : array[1..3] of Byte;
    Info : Integer;
  begin
    Info := stBadMode;
    if (AMode = stOpenRead) or (AMode = stOpenWrite) then
    begin
      Info := stStreamFail;
      if TFilter.Init(ABase) then
      begin
        if Status = stOK then
        begin
          Info := stMemError;
          Startofs := Base^.GetPos;
          Position := 0;
          Mode := AMode;

          if MaxAvail >= SizeOf(TLZWTables) then
          begin
            Info := stSigError;
            GetMem(Tables, SizeOf(TLZWTables));
            Initialise(Tables);
            if Mode = stOpenRead then
            begin
              Base^.Read(Size, SizeOf(Size));
              Base^.Read(Buffer, 3);
              CheckBase;
              if GetSignature(Buffer, Buffer, Tables) then
                Exit;             { Successfully opened for reading }
            end
            else if Mode = stOpenWrite then
            begin
              Size := 0;
              Base^.Write(Size, SizeOf(Size)); { Put a place holder }
              CheckBase;
              if PutSignature(Tables) then
                Exit;             { Successful construction for writing! }
            end;
          end;
        end;
      end;
    end;
    Error(stInitError, Info);
  end;

  destructor TLZWFilter.Done;
  begin
    Flush;
    FreeMem(Tables, SizeOf(TLZWTables));
    TFilter.Done;
  end;

  procedure TLZWFilter.Write(var Buf; Count : Word);
  var
    Inbuf : array[0..65520] of Byte absolute Buf;
    Outbuf : array[0..255] of Byte;
    Inptr : Word;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenWrite then
        Error(stBadMode, Mode);
      Inptr := 0;
      repeat
        Pointer(Sizes) := Crunch(Count, SizeOf(Outbuf),
                                 Inbuf[Inptr], Outbuf, Tables);
        with Sizes do
        begin
          Base^.Write(Outbuf, OutSize);

          Dec(Count, UsedSize);
          Inc(Inptr, UsedSize);
          Inc(Size, UsedSize);
          Inc(Position, UsedSize);
        end;
      until Count = 0;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Flush;
  var
    Outbuf : array[0..255] of Byte;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
    Pos : LongInt;
  begin
    if CheckStatus then
    begin
      if Mode = stOpenWrite then
      begin
        Pointer(Sizes) := Crunch(1, SizeOf(Outbuf), Outbuf, Outbuf, Tables);
        { Push one more character to match JA bug }
        with Sizes do
        begin
          Base^.Write(Outbuf, OutSize);

          OutSize := FlushLZW(Outbuf, Tables); { And flush }
          Base^.Write(Outbuf, OutSize);
        end;
        Pos := Base^.GetPos;
        Base^.Seek(Startofs);
        Base^.Write(Size, SizeOf(Size));
        Base^.Seek(Pos);
      end;
      Base^.Flush;
      Mode := 0;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Read(var Buf; Count : Word);
  var
    Outbuf : array[0..65520] of Byte absolute Buf;
    Inbuf : array[0..255] of Byte;
    OutPtr : Word;
    BlockSize : Word;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
    BytesLeft : LongInt;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenRead then
        Error(stBadMode, Mode);
      OutPtr := 0;
      BlockSize := SizeOf(Inbuf);
      with Base^ do
        BytesLeft := GetSize-GetPos;

      if Position+Count > Size then
      begin
        Error(stReaderror, 0);
        FillChar(Buf, Count, 0);
        Exit;
      end;

      while Count > 0 do
      begin
        if BytesLeft < BlockSize then
          BlockSize := BytesLeft;
        Base^.Read(Inbuf, BlockSize);
        Pointer(Sizes) := Uncrunch(BlockSize, Count, Inbuf,
                                   Outbuf[OutPtr], Tables);
        with Sizes do
        begin
          if OutSize = 0 then
          begin
            Error(stReaderror, 0);
            FillChar(Outbuf[OutPtr], Count, 0);
            Exit;
          end;
          Dec(BytesLeft, UsedSize);
          Inc(Position, OutSize);
          Dec(Count, OutSize);
          Inc(OutPtr, OutSize);
          if UsedSize < BlockSize then
            with Base^ do         { seek back to the first unused byte }
              Seek(GetPos-(BlockSize-UsedSize));
        end;
      end;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Seek(Pos : LongInt);
  var
    Buf : array[0..255] of Byte;
    Bytes : Word;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenRead then
      begin
        Error(stBadMode, Mode);
        Exit;
      end;
      if Pos < Position then
      begin
        Base^.Seek(Startofs);
        FreeMem(Tables, SizeOf(TLZWTables));

        TLZWFilter.Init(Base, Mode); { Re-initialize everything.  Will this cause
                                     bugs in descendents? }
      end;
      while Pos > Position do
      begin
        if Pos-Position > SizeOf(Buf) then
          Bytes := SizeOf(Buf)
        else
          Bytes := Pos-Position;
        Read(Buf, Bytes);
      end;
    end;
  end;

  procedure TLZWFilter.Truncate;
  begin
    Error(stBadMode, Mode);
  end;

  function TLZWFilter.GetPos;
  begin
    GetPos := Position;
  end;

  function TLZWFilter.GetSize;
  begin
    GetSize := Size;
  end;

  { ***** Text Filter Code ******* }

  { These declarations are used both by TTextFilter and TLogFilter }

type
  TFDDfunc = function(var F : Text) : Integer;

  PStreamTextRec = ^StreamTextRec;
  PSaveText = ^TSaveText;
  TSaveText =
    record                        { Used when logging for original data values }
      OpenFunc,
      InOutFunc,
      FlushFunc,
      CloseFunc : TFDDfunc;
      S : PLogFilter;
      SaveData : PSaveText;
      Next : PStreamTextRec;
      Data : array[13..16] of Byte;
    end;

  StreamTextRec =
    record
      Handle : Word;
      Mode : Word;
      BufSize : Word;
      private : Word;
      BufPos : Word;
      BufEnd : Word;
      BufPtr : Pbyte_array;
      OpenFunc,
      InOutFunc,
      FlushFunc,
      CloseFunc : TFDDfunc;
      S : PFilter;                { This is a TTextFilter or a TLogFilter }
      SaveData : PSaveText;
      Next : PStreamTextRec;
      OtherData : array[13..16] of Byte;
      Name : array[0..79] of Char;
      Buffer : array[0..127] of Byte;
    end;

  function TextIn(var F : Text) : Integer; Far;
  var
    savemode : word;
  begin
    with StreamTextRec(F), S^ do
    begin
      if Status = 0 then
      begin
        savemode := mode;
        mode := fmClosed;               { This stops infinite loop }
        if GetSize-GetPos > BufSize then
        begin
          Read(BufPtr^, BufSize);
          BufEnd := BufSize;
        end
        else
        begin
          BufEnd := GetSize-GetPos;
          if BufEnd > 0 then
            Read(BufPtr^, BufEnd);
        end;
        mode := savemode;
      end;
      TextIn := Status;
    end;
  end;

  function TextOut(var F : Text) : Integer; Far;
  var
    savemode : word;
  begin
    with StreamTextRec(F), S^ do
    begin
      if Status = 0 then
      begin
        savemode := mode;
        mode := fmClosed;
        Write(BufPtr^, BufPos);
        mode := savemode;
        BufPos := 0;
      end;
      TextOut := Status;
    end;
  end;

  function TextInFlush(var F : Text) : Integer; Far;
  begin
  end;

  function TextOutFlush(var F : Text) : Integer; Far;
  begin
    TextOutFlush := TextOut(F);
  end;

  function TextClose(var F : Text) : Integer; Far;
  begin
    TextClose := StreamTextRec(F).S^.Status;
  end;

  function TextOpen(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      case Mode of
        fmInOut : Mode := fmOutput;
        fmOutput :
        begin
                  Mode := fmClosed;
                  S^.Seek(S^.Startofs);
                  Mode := fmOutput;
        end;
      end;
      case Mode of
        fmInput : begin
                    InOutFunc := TextIn;
                    FlushFunc := TextInFlush;
                  end;
        fmOutput : begin
                     InOutFunc := TextOut;
                     FlushFunc := TextOutFlush;
                   end;
      end;
      TextOpen := S^.Status;
    end;
  end;

  constructor TTextFilter.Init(ABase : PStream; AName : String);
  begin
    if not TFilter.Init(ABase) then
      Fail;
    with StreamTextRec(Textfile) do
    begin
      Mode := fmClosed;
      BufSize := SizeOf(Buffer);
      BufPtr := @Buffer;
      OpenFunc := TextOpen;
      CloseFunc := TextClose;
      AName := Copy(AName, 1, 79);
      Move(AName[1], Name, Length(AName));
      Name[Length(AName)] := #0;
      S := @Self;
    end;
  end;

  destructor TTextFilter.Done;
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      Close(Textfile);
    TFilter.Done;
  end;

  function TTextFilter.GetPos : LongInt;
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    GetPos := TFilter.GetPos;
  end;

  function TTextFilter.GetSize : LongInt;
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    GetSize := TFilter.GetSize;
  end;

  procedure TTextFilter.Read(var Buf; Count : Word);
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    TFilter.Read(Buf,Count);
  end;

  procedure TTextFilter.Seek(Pos : LongInt);
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    TFilter.Seek(Pos);
  end;

  procedure TTextFilter.Truncate;
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    TFilter.Truncate;
  end;

  procedure TTextFilter.Write(var Buf; Count : Word);
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      System.Flush(TextFile);
    TFilter.Write(Buf,Count);
  end;

  function DoOldCall(Func : TFDDfunc; var F : Text) : Integer;
  var
    Save : TSaveText;
  begin
    if @Func <> nil then
      with StreamTextRec(F) do
      begin
        Move(OpenFunc, Save, SizeOf(TSaveText));
        Move(SaveData^, OpenFunc, SizeOf(TSaveText)); { Now using old functions }
        DoOldCall := Func(F);
        Move(OpenFunc, Save.SaveData^, SizeOf(TSaveText)); { Save any changes }
        Move(Save, OpenFunc, SizeOf(TSaveText)); { Back to new ones }
      end;
  end;

  function LogIn(var F : Text) : Integer; Far;
  var
    Result : Integer;
  begin
    with StreamTextRec(F) do
    begin
      Result := DoOldCall(SaveData^.InOutFunc, F);
      if Result = 0 then
        S^.Write(BufPtr^, BufEnd); { Might want to record errors
                                               here }
      LogIn := Result;
    end;
  end;

  function LogOut(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      S^.Write(BufPtr^, BufPos);
      LogOut := DoOldCall(SaveData^.InOutFunc, F);
    end;
  end;

  function LogInFlush(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
      LogInFlush := DoOldCall(SaveData^.FlushFunc, F);
  end;

  function LogOutFlush(var F : Text) : Integer; Far;
  var
    OldPos : Word;
  begin
    with StreamTextRec(F) do
    begin
      OldPos := BufPos;
      LogOutFlush := DoOldCall(SaveData^.FlushFunc, F);
      if BufPos = 0 then
        S^.Write(BufPtr^, OldPos);
    end;
  end;

  function LogClose(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      LogClose := DoOldCall(SaveData^.CloseFunc, F);
      if not PLogFilter(S)^.Unlog(F) then
        { Bug! } ;
    end;
  end;

  function LogOpen(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      LogOpen := DoOldCall(SaveData^.OpenFunc, F);
      case Mode of
        fmInOut, fmOutput : begin
                              InOutFunc := LogOut;
                              if @FlushFunc <> nil then
                                FlushFunc := LogOutFlush;
                            end;
        fmInput : begin
                    InOutFunc := LogIn;
                    if @FlushFunc <> nil then
                      FlushFunc := LogInFlush;
                  end;
      end;
    end;
  end;

  { ******* TLogFilter methods ******** }

  constructor TLogFilter.Init(Abase:PStream);
  begin
    if not TFilter.init(ABase) then
      fail;
    LogList := nil;
  end;

  destructor TLogFilter.Done;
  begin
    while (LogList <> nil) and Unlog(LogList^) do ;
    TFilter.Done;
  end;

  procedure TLogFilter.Log(var F : Text);
  var
    Save : PSaveText;
    OldOpen : TFDDfunc;
    Junk : Integer;

  begin
    New(Save);
    with StreamTextRec(F) do
    begin
      Move(OpenFunc, Save^, SizeOf(TSaveText)); { Save the original contents }
      S := @Self;
      SaveData := Save;
      Next := PStreamTextRec(LogList);
      LogList := @F;              { Insert this file into the list of logged files }
      OldOpen := SaveData^.OpenFunc;
      Pointer(@SaveData^.OpenFunc) := nil; { Call LogOpen, but don't open. }
      Junk := LogOpen(F);
      SaveData^.OpenFunc := OldOpen;
      CloseFunc := LogClose;
    end;
  end;

  function TLogFilter.Unlog(var F : Text) : Boolean;
  var
    Save : PSaveText;
    Prev : PStreamTextRec;
  begin
    Unlog := False;               { Assume failure }
    with StreamTextRec(F) do
    begin
      if S = @Self then
      begin
        { First, delete it from the list. }
        if LogList = @F then
          LogList := Pointer(Next)
        else
        begin
          Prev := PStreamTextRec(LogList);
          while (Prev^.Next <> nil) and (Prev^.Next <> @F) do
            Prev := Prev^.Next;
          if Prev^.Next <> @F then
            Exit;                 { Couldn't find it in the list!? }
          Prev^.Next := Next;
        end;
        Save := SaveData;
        Move(Save^, OpenFunc, SizeOf(TSaveText));
        Dispose(Save);
        Unlog := True;
      end;
    end;
  end;

{$ifndef windows}

  { ****** Overlay stream code ****** }

type
  { This is the structure at the start of each "thunk" segment }
  POvrhead = ^TOvrhead;
  TOvrhead = record
               Signature : Word;  { CD 3F  - INT 3F call used on returns }
               Ret_Ofs : Word;    { The offset to jump to when a return triggers a
                            reload }
               Offset : LongInt;  { The offset to the segment in the .OVR file }
               Code_Bytes,        { Size of the code image }
               Reloc_Bytes,       { Number of relocation fixups times 2 }
               Entry_Count,       { The number of entry points }
               NextSeg,           { Next overlay segment - add prefixseg + $10 to find
                            thunks.  List starts with System.ovrcodelist. }
               LoadSeg,           { The segment at which the overlay is loaded, or 0 }
               Reprieve,          { Set to 1 to if overlay used while on probation }
               NextLoaded : Word; { The segment of the next loaded overlay.  List starts
                            with System.ovrloadlist.  Updated *after* call to
                            ovrreadbuf. }
               case Integer of
                 1 : (EMSPage,    { The EMS page where this overlay is stored }
                      EMSOffset : Word); { The offset within the EMS page }
                 2 : (S : PStream; { The stream holding this segment's code }
                      Soffset : LongInt); { The offset within S }
             end;

var
  OldReadFunc : OvrReadFunc;
  OvrOldExitProc : Pointer;
  OvrStream : PStream;
const
  OvrStreamInstalled : Boolean = False;
  OvrExitHandler : Boolean = False;

  function OvrPtr(Seg : Word) : POvrhead;
{ Convert map style segment number, as used by overlay manager, to
  pointer }
  begin
    OvrPtr := Ptr(Seg+PrefixSeg+$10, 0);
  end;

  function StdPtr(Seg : Word) : POvrhead;
    { Convert straight segment number to a pointer }
  begin
    StdPtr := Ptr(Seg, 0);
  end;

  function NewReadFunc(OvrSeg : Word) : Integer; Far;
  var
    Result : Integer;
  begin
    with StdPtr(OvrSeg)^ do
    begin
      if S = nil then
      begin                       { Segment not yet loaded }
        Result := OldReadFunc(OvrSeg);
        if Result = 0 then
        begin
          { Now copy the loaded code to our stream }
          Soffset := OvrStream^.GetSize;
          OvrStream^.Seek(Soffset);
          OvrStream^.Write(Ptr(LoadSeg, 0)^, Code_Bytes);
          Result := OvrStream^.Status;
          if Result = stOK then
            S := OvrStream
          else
            OvrStream^.Reset;     { Something failed; hope we haven't messed
                              up the stream too much }
        end;
      end
      else
      begin                       { Segment has been loaded into the stream }
        S^.Seek(Soffset);
        S^.Read(Ptr(LoadSeg, 0)^, Code_Bytes);
        Result := S^.Status;
        if Result <> stOK then
        begin
          S^.Reset;               { Fix the stream, and try a standard load }
          Result := OldReadFunc(OvrSeg);
        end;
      end;
    end;
    NewReadFunc := Result;
  end;

  procedure OvrExitProc; Far;
{ Installed exit procedure; disposes of any streams that are still
  handling overlays. }
  begin
    ExitProc := OvrOldExitProc;
    OvrDisposeStreams;
  end;

  procedure OvrInitStream(S : PStream);
  begin
    if not OvrStreamInstalled then
    begin
      OldReadFunc := OvrReadBuf;  { Install our reader function }
      OvrReadBuf := NewReadFunc;
      OvrStreamInstalled := True;
    end;
    if not OvrExitHandler then
    begin
      OvrOldExitProc := ExitProc;
      ExitProc := @OvrExitProc;
      OvrExitHandler := True;
    end;
    OvrStream := S;               { And set stream to use }
  end;

  procedure OvrDetachStream(BadS : PStream);
  var
    OvrSeg : Word;
  begin
    if OvrStreamInstalled then
    begin
      if OvrStream = BadS then
        OvrStream := nil;         { Detach default stream }
      OvrSeg := OvrCodeList;
      while OvrSeg <> 0 do        { Walk the overlay list }
        with OvrPtr(OvrSeg)^ do
        begin
          if S <> nil then
          begin
            if S <> BadS then
            begin
              if OvrStream = nil then
                OvrStream := S;   { Set default stream to first found }
            end
            else
              S := nil;           { Blank out BadS references }
          end;
          OvrSeg := NextSeg;
        end;
      if OvrStream = nil then
      begin
        OvrStreamInstalled := False; { If we don't have a stream, better
                                          uninstall. }
        OvrReadBuf := OldReadFunc;
      end;
    end;
  end;

  procedure OvrDisposeStreams;
  var
    S : PStream;
  begin
    while OvrStreamInstalled and (OvrStream <> nil) do
    begin
      S := OvrStream;
      OvrDetachStream(S);
      Dispose(S, Done);
    end;
  end;

  function OvrSizeNeeded : LongInt;
  var
    OvrSeg : Word;
    Result : LongInt;
  begin
    OvrSeg := OvrCodeList;
    Result := 0;
    while OvrSeg <> 0 do          { Walk the overlay list }
      with OvrPtr(OvrSeg)^ do
      begin
        if S = nil then
          Inc(Result, Code_Bytes);
        OvrSeg := NextSeg;
      end;
    OvrSizeNeeded := Result;
  end;

  function OvrLoadAll : Boolean;
  var
    OvrSeg : Word;
    Junk : Integer;
  begin
    if not OvrStreamInstalled then
      OvrLoadAll := False
    else
    begin
      OvrClearBuf;
      OvrSeg := OvrCodeList;
      while OvrSeg <> 0 do        { Walk the overlay list }
        with OvrPtr(OvrSeg)^ do
        begin
          if S = nil then
          begin
            LoadSeg := OvrHeapOrg; { load at start of overlay buffer }
            Junk := NewReadFunc(OvrSeg+PrefixSeg+$10);
            LoadSeg := 0;         { Don't really want it loaded yet }
          end;
          OvrSeg := NextSeg;
        end;
      OvrLoadAll := OvrStream^.Status = stOK;
    end;
  end;

  {$endif windows}

  { ****** Bit filter code ****** }

  constructor TBitFilter.Init(ABase : PStream);
  begin
    TFilter.Init(ABase);
    BitPos := 0;
    AtEnd := false;
  end;

  procedure TBitFilter.PrepareBuffer(ForRead : Boolean);
  begin
    if BitPos = 8 then            { Buffer full on write }
    begin
      Base^.Write(Buffer, 1);
      BitPos := 0;
    end;
    if BitPos = 0 then            { Buffer empty }
    begin
      if not AtEnd then
      begin
        if not ForRead then
          AtEnd := (Base^.GetPos >= Base^.GetSize);
        if (not AtEnd) or ForRead then
        begin
          Base^.Read(Buffer,1);
          BitPos := -8
        end;
      end;
      if AtEnd then
        Buffer := 0;
      Mask := 1;
    end;
    if (not ForRead) and (BitPos < 0) then
    begin
      Base^.Seek(Base^.GetPos-1);
      Inc(BitPos, 8);
      AtEnd := false;
    end;
  end;

  function TBitFilter.GetBit : TBit;
  begin
    if CheckStatus then
    begin
      PrepareBuffer(True);
      GetBit := TBit((Buffer and Mask) > 0);
      Mask := Mask shl 1;
      Inc(BitPos);
      CheckBase;
    end;
  end;

  function TBitFilter.GetBits(Count : Byte) : LongInt;
  var
    Result : LongInt;
  begin
    Result := 0;
    ReadBits(Result, Count);
    GetBits := Result;
  end;

  procedure TBitFilter.PutBit(ABit : TBit);
  begin
    if CheckStatus then
    begin
      PrepareBuffer(False);
      if ABit = 1 then
        Buffer := Buffer or Mask;
      Mask := Mask shl 1;
      Inc(BitPos);
    end;
  end;

  procedure TBitFilter.PutBits(ABits : LongInt; Count : Byte);
  begin
    WriteBits(ABits, Count);
  end;

  procedure TBitFilter.ReadBits(var Buf; Count : LongInt);
  var
    w : Word;
    b : array[1..2] of Byte absolute w;
    bBuf : TByteArray absolute Buf;
    i, Bytes : Word;
    Shift : Word;
  begin
    if (Count > 0) and CheckStatus then
    begin
      PrepareBuffer(True);
      if BitPos > 0 then
      begin
        Base^.Write(Buffer, 1);
        Dec(BitPos, 8);
      end;
      Shift := BitPos+8;          { the number of bits to shift by }
      Bytes := (Count+Shift-1) div 8; { Count of whole bytes to read }
      if Bytes > 0 then
      begin
        TFilter.Read(Buf, Bytes);
        b[1] := Buffer;
        for i := 0 to Pred(Bytes) do
        begin
          b[2] := bBuf[i];
          w := w shr Shift;
          bBuf[i] := b[1];
          w := w shr (8-Shift);
        end;
        Buffer := b[1];
      end;
      { Now fix up the last few bits }
      Dec(Count, 8*LongInt(Bytes));
      if Count > 0 then
        bBuf[Bytes] := (Buffer shr Shift) and not($FF shl Count)
      else
        if Count < 0 then
          bBuf[Bytes-1] := bBuf[Bytes-1] and not($FF shl (8+Count));
      BitPos := BitPos+Count;
      Mask := 1 shl (BitPos+8);
    end;
  end;

  procedure TBitFilter.WriteBits(var Buf; Count : LongInt);
  var
    w : Word;
    b : array[1..2] of Byte absolute w;
    bBuf : TByteArray absolute Buf;
    i, Bytes : Word;
    Shift : Word;
    SaveBuf : Byte;
    SavePos : ShortInt;
  begin
    if CheckStatus then
    begin
      PrepareBuffer(False);
      Bytes := (Count+BitPos-1) div 8; { Count of whole bytes to write }
      Shift := 8-BitPos;
      if Bytes > 0 then
      begin
        if Shift < 8 then
        begin
          b[1] := Buffer shl Shift;
          for i := 0 to Pred(Bytes) do
          begin
            b[2] := bBuf[i];
            w := w shr Shift;
            Base^.Write(b[1], 1);
            w := w shr (8-Shift);
          end;
          Buffer := b[1] shr Shift;
        end
        else
          Base^.Write(Buf, Bytes);
      end;
      Dec(Count, 8*LongInt(Bytes));
      if Count > 0 then
        Buffer := (Buffer or (bBuf[Bytes] shl (8-Shift)));
      BitPos := BitPos+Count;
      if BitPos > 0 then          { Fill in upper part of buffer }
      begin
        SaveBuf := Buffer;
        SavePos := BitPos;
        BitPos := 0;              { signal empty buffer }
        PrepareBuffer(False);     { and load it }
        Buffer := (Buffer and ($FF shl SavePos)) { old part }
                  or (SaveBuf and not($FF shl SavePos)); { new part }
        BitPos := SavePos;
      end;
      Mask := 1 shl BitPos;
      CheckBase;
    end;
  end;

  procedure TBitFilter.Flush;
  begin
    if CheckStatus then
    begin
      if BitPos > 0 then
        Base^.Write(Buffer, 1);
      Dec(BitPos, 8);
      AtEnd := false;
      CheckBase;
    end;
  end;

  procedure TBitFilter.Seek(Pos : LongInt);
  begin
    if CheckStatus then
    begin
      Flush;
      TFilter.Seek(Pos);
      BitPos := 0;
      AtEnd := false;
    end;
  end;

  procedure TBitFilter.Read(var Buf; Count : Word);
  begin
    ReadBits(Buf, 8*LongInt(Count));
  end;

  procedure TBitFilter.Write(var Buf; Count : Word);
  begin
    WriteBits(Buf, 8*LongInt(Count));
  end;

  procedure TBitFilter.SeekBit(Pos : LongInt);
  var
    i : Byte;
    b : TBit;
  begin
    if CheckStatus then
    begin
      Seek(Pos div 8);
      for i := 1 to (Pos and 7) do
        b := GetBit;
    end;
  end;

  function TBitFilter.GetBitPos : LongInt;
  begin
    GetBitPos := 8*TFilter.GetPos+BitPos;  { Need TFilter override in
                                             case descendants override
                                             GetPos }
  end;

  procedure TBitFilter.CopyBits(var S : TBitFilter; Count : LongInt);
  var
    localbuf : array[1..256] of Byte;
  begin
    while Count > 2048 do
    begin
      S.ReadBits(localbuf, 2048);
      WriteBits(localbuf, 2048);
      Dec(Count, 2048);
    end;
    if Count > 0 then
    begin
      S.ReadBits(localbuf, Count);
      WriteBits(localbuf, Count);
    end;
  end;

  procedure TBitFilter.ByteAlign;
  begin
    SeekBit((GetBitPos+7) and $FFFFFFF8);
  end;

  { ****** Duplicate filter code ****** }

  constructor TDupFilter.Init(ABase, ABase2 : PStream);
  { Initialize the filter with the given bases. }
  begin
    if not TFilter.Init(Abase) then
      fail;
    Base2 := ABase2;
    CheckBase2;
    if Status = stOK then
      Startofs2 := Base2^.GetPos;
  end;

  destructor TDupFilter.Done;
  { Flush filter, then dispose of both bases. }
  begin
    Flush;
    if Base2 <> nil then
      Dispose(Base2,done);
    TFilter.Done;
  end;

  function TDupFilter.MisMatch(var buf1,buf2;count:word):word;
  var
    i : word;
    bbuf1 : TByteArray absolute buf1;
    bbuf2 : TByteArray absolute buf2;
  begin
    for i := 0 to pred(count) do
      if bbuf1[i] <> bbuf2[i] then
      begin
        MisMatch := succ(i);
        exit;
      end;
    MisMatch := 0;
  end;

  procedure TDupFilter.Read(var Buf; Count : Word);
  var
    bpos : word;
    localbuf : array[0..255] of byte;

    procedure CompareBuffer(size:word);
    var
      epos : word;
      bbuf : TByteArray absolute Buf;
    begin
      Base2^.Read(localbuf,size);
      dec(count,size);
      CheckBase2;
      if status = stOK then
      begin
        epos := MisMatch(bbuf[bpos],localbuf,size);
        if epos <> 0 then
          Error(stMismatch,bpos+epos);
      end;
      inc(bpos,size);
    end;

  begin
    TFilter.Read(buf, Count);
    bpos := 0;
    While (Status = stOK) and (Count >= sizeof(localbuf)) do
      CompareBuffer(Sizeof(localbuf));
    If (Status = stOK) and (Count > 0) then
      CompareBuffer(Count);
    { Be sure the bases are synchronized }
    Base2^.Seek(GetPos+StartOfs2);
  end;

  procedure TDupFilter.Seek(Pos : LongInt);
  begin
    TFilter.Seek(Pos);
    if Status = stOK then
    begin
      base2^.Seek(pos+startofs2);
      CheckBase2;
    end;
  end;

  procedure TDupFilter.Truncate;
  begin
    TFilter.Truncate;
    if Status = stOK then
    begin
      base2^.truncate;
      CheckBase2;
    end;
  end;

  procedure TDupFilter.Write(var Buf; Count : Word);
  begin
    TFilter.Write(buf,Count);
    if Status = stOK then
    begin
      Base2^.write(buf,Count);
      CheckBase2;
    end;
  end;

  procedure TDupFilter.Flush;
  begin
    TFilter.Flush;
    if Status = stOK then
    begin
      base2^.flush;
      CheckBase2;
    end;
  end;

  function TDupFilter.CheckStatus : Boolean;
  begin
    if TFilter.CheckStatus then
      if Base2^.Status <> stOK then
        Base2^.Reset;
    CheckStatus := Status = stOK;
  end;

  procedure TDupFilter.CheckBase2;
  begin
    if Base2^.status <> stOk then
      Error(stBase2Error,Base2^.status);
  end;

  { ****** Checksum/CRC code ******}

  Function UpdateChksum(initsum:word; var Inbuf; inlen:word):word;
  var
    i : word;
    bbuf : TByteArray absolute inbuf;
  begin
    for i:=0 to pred(inlen) do
      inc(initsum,bbuf[i]);
    UpdateChksum := initsum;
  end;

{ From the original CRC.PAS: }

{ This unit provides three speed-optimized functions to compute (or continue
  computation of) a Cyclic Redundency Check (CRC).  These routines are
  contributed to the public domain (with the limitations noted by the
  original authors in the TASM sources).

  Each function takes three parameters:

  InitCRC - The initial CRC value.  This may be the recommended initialization
  value if this is the first or only block to be checked, or this may be
  a previously computed CRC value if this is a continuation.

  InBuf - An untyped parameter specifying the beginning of the memory area
  to be checked.

  InLen - A word indicating the length of the memory area to be checked.  If
  InLen is zero, the function returns the value of InitCRC.

  The function result is the updated CRC.  The input buffer is scanned under
  the limitations of the 8086 segmented architecture, so the result will be
  in error if InLen > 64k - Offset(InBuf).

  These conversions were done on 10-29-89 by:

  Edwin T. Floyd [76067,747]
  #9 Adams Park Court
  Columbus, GA 31909
  [phone] (work)
  [phone] (home)
}

Function UpdateCRC16(InitCRC : Word; Var InBuf; InLen : Word) : Word;
  external; {$L crc16.obj}
{ I believe this is the CRC used by the XModem protocol.  The transmitting
  end should initialize with zero, UpdateCRC16 for the block, Continue the
  UpdateCRC16 for two nulls, and append the result (hi order byte first) to
  the transmitted block.  The receiver should initialize with zero and
  UpdateCRC16 for the received block including the two byte CRC.  The
  result will be zero (why?) if there were no transmission errors.  (I have
  not tested this function with an actual XModem implementation, though I
  did verify the behavior just described.  See TESTCRC.PAS.) }


Function UpdateCRCArc(InitCRC : Word; Var InBuf; InLen : Word) : Word;
  external; {$L crcarc.obj}
{ This function computes the CRC used by SEA's ARC utility.  Initialize
  with zero. }

Function UpdateCRC32(InitCRC : LongInt; Var InBuf; InLen : Word) : LongInt;
  external; {$L crc32.obj}
{ This function computes the CRC used by PKZIP and Forsberg's ZModem.
  Initialize with high-values ($FFFFFFFF), and finish by inverting all bits
  (Not). }

  { ****** Sequential filter code ****** }

  procedure TSequential.Seek(pos:longint);
  begin
    Error(stUnsupported,0);
  end;

  { ****** Chksum filter code ******}

  constructor TChkSumFilter.init(ABase:PStream; AChksum:word);
  begin
    if not TSequential.init(ABase) then
      fail;
    Chksum := AChksum;
  end;

  procedure TChkSumFilter.Read(var buf; Count:word);
  begin
    TSequential.Read(buf,count);
    if status = stOK then
      ChkSum := UpdateChksum(ChkSum,buf,Count);
  end;

  procedure TChkSumFilter.Write(var buf; Count:word);
  begin
    TSequential.Write(buf,count);
    if status = stOk then
      ChkSum := UpdateChksum(ChkSum,buf,Count);
  end;

{ ***** CRC16 filter code ***** }

  constructor TCRC16Filter.init(ABase:PStream; ACRC16:word);
  begin
    if not TSequential.init(ABase) then
      fail;
    CRC16 := ACRC16;
  end;

  procedure TCRC16Filter.Read(var buf; Count:word);
  begin
    TSequential.Read(buf,count);
    if status = stOK then
      CRC16 := UpdateCRC16(CRC16,buf,count);
  end;

  procedure TCRC16Filter.Write(var buf; Count:word);
  begin
    TSequential.Write(buf,count);
    if status = stOk then
      CRC16 := UpdateCRC16(CRC16,buf,count);
  end;

  { ***** CRCARC filter code ***** }

  constructor TCRCARCFilter.init(ABase:PStream; ACRCARC:word);
  begin
    if not TSequential.init(ABase) then
      fail;
    CRCARC := ACRCARC;
  end;

  procedure TCRCARCFilter.Read(var buf; Count:word);
  begin
    TSequential.Read(buf,count);
    if status = stOK then
      CRCARC := UpdateCRCARC(CRCARC,buf,count);
  end;

  procedure TCRCARCFilter.Write(var buf; Count:word);
  begin
    TSequential.Write(buf,count);
    if status = stOk then
      CRCARC := UpdateCRCARC(CRCARC,buf,count);
  end;

  { ***** CRC32 filter code ***** }

  constructor TCRC32Filter.init(ABase:PStream; ACRC32:longint);
  begin
    if not TSequential.init(ABase) then
      fail;
    CRC32 := ACRC32;
  end;

  procedure TCRC32Filter.Read(var buf; Count:word);
  begin
    TSequential.Read(buf,count);
    if status = stOK then
      CRC32 := UpdateCRC32(CRC32,buf,count);
  end;

  procedure TCRC32Filter.Write(var buf; Count:word);
  begin
    TSequential.Write(buf,count);
    if status = stOk then
      CRC32 := UpdateCRC32(CRC32,buf,count);
  end;

  { ****** Null stream code ****** }

  constructor TNulStream.Init;
  begin
    TStream.Init;
    Position := 0;
    Value := AValue;
  end;

  function TNulStream.GetPos;
  begin
    GetPos := Position;
  end;

  function TNulStream.GetSize;
  begin
    GetSize := Position;
  end;

  procedure TNulStream.Read;
  begin
    FillChar(Buf, Count, Value);
    Inc(Position, Count);
  end;

  procedure TNulStream.Seek;
  begin
    Position := Pos;
  end;

  procedure TNulStream.Write;
  begin
    Inc(Position, Count);
  end;

  { ****** RAM stream code ****** }

  constructor TRAMStream.Init(Asize : Word);
  begin
    TStream.Init;
    Position := 0;
    Size := 0;
    Alloc := Asize;
    if MaxAvail < Alloc then
      Fail;
    GetMem(Buffer, Alloc);
    OwnMem := True;
    FillChar(Buffer^, Alloc, 0);
  end;

  constructor TRAMStream.UseBuf(ABuffer : Pointer; Asize : Word);
  begin
    TRAMStream.Init(0);
    Alloc := Asize;
    Buffer := ABuffer;
    OwnMem := False;
  end;

  destructor TRAMStream.Done;
  begin
    if OwnMem then
      FreeMem(Buffer, Alloc);
    TStream.Done;
  end;

  function TRAMStream.GetPos;
  begin
    GetPos := Position;
  end;

  function TRAMStream.GetSize;
  begin
    GetSize := Size;
  end;

  procedure TRAMStream.Read;
  begin
    if Position+Count > Size then
    begin
      Error(stReaderror, 0);
      FillChar(Buf, Count, 0);
    end
    else
    begin
      Move(Buffer^[Position], Buf, Count);
      Inc(Position, Count);
    end;
  end;

  procedure TRAMStream.Seek;
  begin
    if Pos > Size then
      Error(stReaderror, 0)
    else
      Position := Pos;
  end;

  procedure TRAMStream.Truncate;
  begin
    Size := Position;
  end;

  procedure TRAMStream.Write;
  begin
    if Position+Count > Alloc then
      Error(stWriteError, 0)
    else
    begin
      Move(Buf, Buffer^[Position], Count);
      Inc(Position, Count);
      if Position > Size then
        Size := Position;
    end;
  end;

  { ***** XMS stream code ***** }

  {$I xmsstrm.inc}

  { ***** Named Buffered file stream code ***** }

  constructor TNamedBufStream.Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
  begin
    if TBufStream.Init(Name, Mode, ABufSize) then
    {$ifdef windows}
    filename := StrNew(name)
    {$else}
      Filename := NewStr(Name)
    {$endif}
    else
      Fail;
  end;

  destructor TNamedBufStream.Done;
  begin
  {$ifdef windows}
  StrDispose(filename);
  {$else}
    DisposeStr(Filename);
  {$endif}
    TBufStream.Done;
  end;

  constructor TTempBufStream.Init(ABufSize : Word);
  var
    p : Pchar;
    TempName : String;
    Okay : Boolean;
    NewHandle : Word;
  begin
    if not TStream.Init then
      Fail;
    if MaxAvail < ABufSize then
      Fail;
    BufSize := ABufSize;
    GetMem(Buffer, BufSize);

  {$ifdef windows}
  p := GetEnvVar('TEMP');
  if p <> nil then
    tempname := StrPas(p)
  else
    tempname := '';
  {$else}
    TempName := GetEnv('TEMP');
  {$endif}
    if Length(TempName) = 0 then
      TempName := '.\';
    if TempName[Length(TempName)] <> '\' then
      TempName := TempName+'\';
    FillChar(TempName[Length(TempName)+1], 255-Length(TempName), #0);
    asm
      push    ds
      push    ss
      pop     ds
      lea     dx,TempName[1]
      mov     ah, $5a
      xor     cx,cx
    {$ifdef windows}
    call dos3call
    {$else}
      int     $21                 { Create temporary file. }
    {$endif}
      pop     ds
      jc      @failed
      mov     Okay,True
      mov     NewHandle,ax
      jmp     @done
@failed:
      mov     Okay,False
@done:
    end;
    if not Okay then
      Fail;
    Handle := NewHandle;
    while TempName[Length(TempName)+1] <> #0 do
      Inc(TempName[0]);
  {$ifdef windows}
  filename := StrNew(StrPCopy(@tempname,tempname));
  {$else}
    Filename := NewStr(TempName);
  {$endif}
  end;

  destructor TTempBufStream.Done;
  var
    F : file;
  begin
  {$ifdef windows}
  assign(f,StrPas(Filename));
  {$else}
    Assign(F, Filename^);
  {$endif}
    TNamedBufStream.Done;
    Erase(F);
  end;

  { ***** Temp Stream Code ******* }

  function TempStream(InitSize, MaxSize : LongInt;
                      Preference : TStreamRanking) : PStream;
  var
    Choice : Integer;
    Result : PStream;
    StreamType : TStreamType;
    Nulls : TNulStream;
  begin
    Result := nil;
    Nulls.Init(0);
    for Choice := 1 to NumTypes do
    begin
      StreamType := Preference[Choice];
      case StreamType of
        RAMStream :
          if MaxSize < $10000 then
            Result := New(PRAMStream, Init(MaxSize));
        EMSStream :
          Result := New(PEMSStream, Init(InitSize, MaxSize));
        XMSStream :
          if xms_MaxAvail > MaxSize div xms_BlockSize then
            Result := New(PXMSStream, Init(MaxSize div xms_BlockSize+1));
        FileStream :
          Result := New(PTempBufStream, Init(2048));
      end;
      if (Result <> nil) and (Result^.Status = stOK) then
      begin
        Result^.Copyfrom(Nulls, InitSize);
        Result^.Seek(0);
        if Result^.Status = stOK then
        begin
          Nulls.Done;
          TempStream := Result;
          Exit;
        end;
      end;
      if Result <> nil then
        Dispose(Result, Done); { Clean up and start over } ;
      Result := nil;
    end;
    TempStream := nil;
  end;
end.